c###esreg.for
      SUBROUTINE ESREG
C--------------------------------
C
C     THIS ROUTINE COMPUTES AN ES - F MODE.  IT IS A COMBINATION OF
C     SUBROUTINE REGMOD AND SUBROUTINE ESMOD.  ONE ES HOP IS DONE AND
C     THE REMAINDER ARE F HOPS.  THE POINT IS TO ADD NEW RADIATION
C     ANGLE POSSIBILITIES.
C     YOU CANNOT HAVE REGULAR E - N*F MODE FROM THE SAME IONOSPHERE
C     ONE COULD USE THE LOGIC BELOW TO MIX MODES FROM TWO OR MORE
C     SAMPLE AREAS
C
C AC(3) IS ABSORPTION LOSS FACTOR, SEE LUFFY.
C BC(3) IS DENOMINATOR OF LOSS FACTOR.
c
      COMMON/ANOIS/ATNU,ATNY,CC,TM,RCNSE,DU,DL,SIGM,SXGU,SXGL,KJ,JK
      COMMON / CONTRL / IELECT(3), KTOUT(12), MONTHS(12), SUNSP(12),
     A IANTOU, ICARD, INTEG, IRED, ISOUT, ISPROC, ISSN, ITYPE, JDASH,
     B JFREQ, JLONG, KCARD, KRUN, MAPIN, MAXNAM, MONOLD, MOREM, MORES,
     C NUMNAM, NUPROC, MAXMET, MSPEC, M100
      COMMON/MUFS/EMUF(24),F1MUF(24),F2MUF(24),ESMUF(24),ALLMUF(24)
     A,FOT(24),XLUF(24),HPF(24),ANGMUF(24),MODMUF,SIGL(4),SIGU(4),DELMUF
     B (4),HPMUF(4),HTMUF(4),FVMUF(4),AFMUF(4),NHOPMF(4),YFOT(4),YHPF(4)
     C ,YMUF(4)
      COMMON/SIGD/DSL,ASM,DSU,AGLAT,DSLF,ASMF,DSUF,ACAV,FEAV,AFE,BFE,HNU
     A ,HTLOSS,XNUZ,XVE
      COMMON /CON /D2R, DCL, GAMA, PI, PI2, PIO2, R2D, RZ, VOFL
      COMMON /DON /ALATD, AMIN, AMIND, BTR, BTRD, DLONG, DMP, ERTR, GCD,
     1 GCDKM, PMP, PWR, TLAT, TLATD, TLONG, TLONGD, RSN, SIGTR, RLAT,
     2 RLATD,RLONG,RLONGD,BRTD,FLUX,ULAT,ULATD,ULONG,ULONGD,SSN,D90R,
     3 D50R,D10R,D90S,D50S,D10S
      COMMON /RON /CLAT(5), CLONG(5), GLAT(5), RD(5), FI(3,5), YI(3,5),
     1HI(3,5), HPRIM(30,5), HTRUE(30,5), FVERT(30,5),KM,KFX, AFAC(30,5),
     2HTR(50,3), FNSQ(50,3)
      COMMON / ZON / ABPS(7), CREL(7), EFF(7), FLDST(7), GRLOS(7),
     1 HN(7), HP(7), PROB(7), RELY(7), RGAIN(7), SIGPOW(7), SN(7),
     2 SPRO(7), TGAIN(7), TIMED(7), TLOSS(7), B(7), FSLOS(7), ADV(7),
     3 OBF(7),NMODE(7),TLLOW(7),TLHGH(7)
      COMMON /TON /ADJ, ADS, GNOS, GOT, REL, SL, SLS
     1, SPR, SU, SUS, XNOISE, ZNOISE, NF
      COMMON/FRQ/FREA(13),FREL(29),FREQ,JMODE,ITXRCP(2)
      COMMON /ES /FS (3, 5), HS (5)
      COMMON / RAYS / ANG(40), IFOB(40,30,5), NANG
      COMMON/REFLX/DELFX(45,3),HPFLX(45,3),HTFLX(45,3),GDFLX(45,3),FVFLX
     A (45,3),DSKPKM(3),DELSKP(3),HPSKP(3),HTSKP(3),DMAXKM(3),FVSKP(3)
     B ,ISKP(3),IMODE(45,3),AFFLX(45,3),DELPEN(3,5),GML(45,3),FHP(45,3)
      COMMON /GEOG /GYZ (5), RAT (5), GMDIP (5), CLCK (5), ABIY (5), ART
     1IC (5), SIGPAT (5), EPSPAT (5)
      DIMENSION LX(3)
      DATA LX/1,3,5/
C PRESET ARRAYS WILL USE SIX ONLY
      IMS = 6
      IME = 7
      DO 100 IM= IMS,IME
      ABPS(IM)  = 1000.
      CREL (IM) = 1000.
      EFF  (IM) =  0.0
      FLDST(IM) = -1000.
      GRLOS(IM) =  +1000.
      HN   (IM) =  -1.
      HP   (IM) =  -1.
      PROB (IM) =  .001
      RELY (IM) =  .001
      RGAIN(IM) =  0.0
      TGAIN(IM) =  0.0
      TIMED(IM) =  -1.
      TLOSS (IM) = 1000.
      B     (IM) =   -1.
      FSLOS (IM) = 1000.
      ADV   (IM) = 1000.
      OBF   (IM) = 1000.
      NMODE (IM) =    5.
      TLLOW (IM) =   10.
      TLHGH (IM) =   10.
      SIGPOW(IM) =-1000.
      SN    (IM) = -1000.
  100 SPRO  (IM) =  .001
C
C  ERRORS IN THE CODE BELOW
C
      RETURN
c
c--ESREG-------------------------------Nothing DONe here!!!
c                                       due to RETURN above
c----------------------------------------------------------
   95 CONTINUE
C DETERMINE EXISTENCE OF ES MODE
      KS= 1
      DO 110 IS = 1,KM
C.....SELECT THE SAMPLE AREA
      IF( FS(2,KS) - FS(2,IS)) 105,110,110
  105 KS= IS
  110 CONTINUE
      IF(FS(2,KS) )  113,113,104
  104 CONTINUE
C.....CUT OFF AT LOW FREQUENCIES. MAPS ARE ES AND E
      FSDEAD = IFOB(1,3,JMODE)
      FSDEAD = FSDEAD/1000.
      FSDEAD = AMIN1(FSDEAD, 3.)
      INS= -1
      IF( FREQ - FSDEAD )  112,111,111
  111 INS= 1
  112 CONTINUE
      IF(INS ) 113,113,114
  113 RETURN
C DETERMINE EXISTENCE OF A F MODE
C.....KF IS THE SAMPLE AREA
  114 KF = JMODE
      IF( FI(2,KF) ) 125,125,115
  115 IF( DELPEN(2,KF) - 89.99)   130,125,125
  125 IF(DELPEN(3,KF) - 89.99) 130,113,113
  130 CONTINUE
C  CHECK FOR MINIMUM ANGLE
      IH = 0
C.....FIND START OF F MODES
      DO 155 IHX = 1,45
      IF( HPFLX(IHX,KF) )  155,155,140
  140 CONTINUE
      IF( DELFX(IHX,KF) - AMIND ) 155,155,145
  145 IF( DELFX(IHX,KF) - DELPEN(1,KF)) 155,155,150
  150 IH = IHX -1
      GO TO 160
  155 CONTINUE
  160 CONTINUE
      IF( IH)  113,113,165
  165 IF( IH - 44) 170,170,113
C  MIXED ES-F MODE EXISTS
  170 IHLOW = IH
      DMAXKM(KF) = GDFLX(IHLOW,KF)
C.....FIND THE MAXIMUM DISTANCE
      DO 185 IH = IHLOW,45
      IF( HPFLX( IH,KF) ) 185,185,175
  175 CONTINUE
      IF(DMAXKM(KF) - GDFLX(IH,KF) ) 180,185,185
  180 DMAXKM(KF) = GDFLX(IH,KF)
  185 CONTINUE
C.....NHOPF IS THE NUMBER OF F HOPS
      NHOPF = GCDKM / DMAXKM(KF) + 1.
      DEL   = DELFX(IHLOW,KF)* D2R
      PHE = RZ* COS(DEL)/( RZ + HS(KS) )
      PHE = ASIN(PHE)
C.....FIND THE ES HOP DISTANCE
      GDR = 2.*RZ*(PIO2 -DEL-PHE)
      HOP = NHOPF
C.....MAXIMUM DISTANCE TO THIS ANGLE
      TGCD = (HOP - 1.) * DMAXKM(KF) + GDR
      IF( TGCD - GCDKM)  195,195,190
C.....REDUCE THE NUMBER OF HOPS
  190 NHOPF = NHOPF -1
  195 CONTINUE
      IF( NHOPF )  600,600,196
  196 CONTINUE
      HOP = NHOPF
      IMD = 6
C  NOW DO MIXED MODE GEOMETRY,(LIKE FDIST)
C.....SEE THE COMMENTS IN SUBROUTINE FDIST FOR THIS SEARCH
      DO 300  IH = IHLOW,44
      IF(HPFLX(IH+1,KF).le.0.) go to 305
      DEL = DELFX(IH,KF)*D2R
      PHE   = RZ* COS(DEL  )/ (RZ + HS(KS))
      PHE   = ASIN(PHE)
      GDR1 = 2.*RZ*(PIO2-DEL-PHE)
      DEL = DELFX(IH+1,KF)*D2R
      PHE = ASIN( RZ*COS(DEL)/(RZ+HS(KS) )  )
      GDR2 = 2.*RZ*(PIO2-DEL-PHE)
      D1 = HOP*GDFLX(IH,KF)+GDR1
      D2 = HOP*GDFLX(IH+1,KF)+GDR2
      IF(D1-D2) 205,205,215
  205 IF(D1-GCDKM) 210,225,300
  210 IF(GCDKM-D2) 230,300,300
  215 IF(D1-GCDKM) 300,225,220
  220 IF(GCDKM-D2) 300,300,230
  225 CONTINUE
      HN(IMD) = NHOPF
      GDR = GDR1
      HP(IMD) = HPFLX(IH,KF)
      B (IMD) = DELFX(IH,KF)
      ISMOD = IMODE(IH,KF)
      HT       =HTFLX(IH,KF)
      AF       =AFFLX(IH,KF)
      FV       =FVFLX(IH,KF)
      GO TO 310
  230 CONTINUE
      IF(ABS(D2-D1)-1.) 225,225,235
  235 CONTINUE
      DTH2 = D2-D1
      GDR = 0.5*(GDR1+GDR2)
      DHOPKM = (GCDKM-GDR)/HOP
      DTH = GCDKM-D1
      THET = 0.5*DHOPKM/RZ
      HP1 = HPFLX(IH,KF)
      HP2 = HPFLX(IH+1,KF)
      HT1 = HTFLX(IH ,KF)
      HT2 = HTFLX(IH+1,KF)
      ISMOD=IMODE(IH ,KF)
      HN(IMD) = NHOPF
      HP(IMD) = HP1 + (HP2 - HP1) * DTH/DTH2
      HT      = HT1 + (HT2 - HT1)*DTH/DTH2
      AF      = AFFLX(IH,KF) +(AFFLX(IH+1,KF)-AFFLX(IH,KF))*DTH/DTH2
      ST = SIN(THET)
      TANP = ST / (1. - COS(THET) + HP(IMD) / RZ)
      PHE  = ATAN(TANP)
      DEL  =  PIO2 - PHE - THET
      B(IMD)= DEL * R2D
      SPHI  = RZ*COS(DEL)/(RZ + HT)
      SPHI  = 1. - SPHI*SPHI
      SPHI = AMAX1(SPHI,0.000001)
      FV   = FREQ *SQRT(SPHI)
      GO TO 310
  300 CONTINUE
  305 CONTINUE
C.....END OF FDIST SEARCH
      GO TO 600
  310 CONTINUE
C FREE SPACE LOSS  AND TIME DELAY
      CDEL = COS(DEL)
      HOP = HN(IMD)
      GHOPF = (GCDKM-GDR)/(RZ*HOP)
      IF(GHOPF.le.0.) go to 600
      PSI   = .5 * GHOPF
      PHE = PIO2 - PSI - DEL
      PATHF = 2.*HOP *( HP(IMD) + RZ * (1. - COS(PSI)))/COS(PHE)
      PSIS =  0.5 * GDR/RZ
      PHES =  PIO2 - PSIS - DEL
      CPHES = COS(PHES)
      PATHS = 2. * ( HS(KS) + RZ *(1. - COS(PSIS)))/ CPHES
      PATH  = PATHF + PATHS
      TIMED(IMD) =  PATH/VOFL
      IF(PATH*FREQ.le.0.) go to 600
      FSLOS(IMD) = 32.45 + 20.*ALOG10(PATH*FREQ)
C  F  ABSORPTION LOSS
      XNSQ = 10.2
      SINP = RZ * CDEL/ (RZ + 100.)
      SECP = 1./SQRT(1.- SINP * SINP)
      AC =  677.2 * ACAV
      L  = LX(KF)
      BC = (FREQ + GYZ(L)) ** 1.98
      ABPSF = SECP *AC / (BC + XNSQ)
      SECP = 1./SIN(DEL + PSI)
      ADV(IMD) = SECP * AF* (( FV + GYZ(L)) ** 1.98 + XNSQ)/(BC+XNSQ)
C ES  ABSORPTION LOSS, MODE DID NOT PASS THROUGH ALL OF E LAYER
      FVS = FREQ /CPHES
      IF( FI(1,KF) - FVS)  320,320,315
  315 ABPS(IMD) = ABPSF
      GO TO 325
  320 ABPS(IMD) = ABPSF + AFE + BFE * ALOG(FVS / FI(1,KF))
  325 CONTINUE
C   F MODE OBSCURATION LOSS FROM ES LAYER
      OBF(IMD) = 0.0
C.....NOT SAME SAMPLE AREA AS F SAMPLE
      IF(FS(2,KF)) 346, 346, 330
  330 FMHZ = AMAX1( FREQ,FSDEAD)
      ESD = FS(2,KF)/ CPHES
      DUMMY = YMUF(4)
      PROS = PRBMUF(FMHZ,ESD,DUMMY,4)
      PROS = AMIN1( PROS, 0.90)
      OBF( IMD) = -10.*ALOG10(1.- PROS)
C F   OVER-THE-MUF LOSS.
  346 SPHET=RZ*CDEL /(RZ + HT)
      CPHET= 1. - SPHET * SPHET
C.....MUF FOR F HOP DISTANCE
      XMUF = FVMUF(ISMOD)/CPHET
      DUMMY = YMUF(ISMOD)
      PROBF = PRBMUF(FREQ,XMUF,DUMMY,ISMOD)
      XLSF = -10.*ALOG10(PROBF)
C ES  OVER-THE-MUF LOSS ( OR REFLECTION LOSS )
C.....MUF FOR ES HOP DISTANCE
      ESD = FS(2,KS)/CPHES
      DUMMY = YMUF(4)
      PROBF = PRBMUF(FREQ,ESD,DUMMY,4)
      REF = 8.9136* PROBF **(-0.7)
C ANTENNA GAINS AND GROUND LOSS
C125PC      if(MSPEC.ne.125)then
        CALL GAIN(1,DEL,FREQ,DUMMY,TEFF)
        TGAIN(IMD) = DUMMY
        CALL GAIN(2,DEL,FREQ,DUMMY1,DUMMY2)
        RGAIN(IMD) = DUMMY1
        EFF(IMD) = DUMMY2
C125PC      else
c.......set gains and EFF to 0. dB or unity
C125PC        tgain(imd)=0.
C125PC        rgain(imd)=0.
C125PC        EFF(imd)=0.
C125PC      ENDIF
      Y = 0.0
      DO  380 IG = 1,KM
      IGX =  - IG
      CALL GAIN(IGX,DEL,FREQ,YG,GEFF)
  380 Y = Y + YG
      XKM = KM
      GRLOS(IMD) = Y/XKM
C
C  NOW SUM MEDIAN LOSSES,ETC.
C
      TLOSS(IMD) = FSLOS(IMD) + HOP * (ABPSF + ADV(IMD) + GRLOS(IMD)
     A + XLSF) +OBF(IMD) + ABPS(IMD) - RGAIN(IMD) - TGAIN(IMD) + REF
      FLDST(IMD) = 107.2+PWRDB(FREQ)+20.*ALOG10(FREQ)-TLOSS(IMD)
     +             -RGAIN(IMD)
      SIGPOW(IMD) = PWRDB(FREQ) - TLOSS(IMD)
C------------    CHANGED 9/24/91  (LONG PATH RCVR EFF CORRECTION)  FJR
C------------      SN(IMD)     = SIGPOW(IMD) - RCNSE
      SN(IMD)     = SIGPOW(IMD) - RCNSE - EFF(IMD)
      NMODE(IMD) = ISMOD
C PROB. FREQ.  LT  F2 MUF  *** AND ***  ES MUF
      DUMMY = YMUF(ISMOD)
      PROBF = PRBMUF(FREQ,DUMMY,DUMMY,ISMOD)
      DUMMY = YMUF(4)
      PROBS = PRBMUF(FREQ,DUMMY,DUMMY,4)
C.....F. DAYS
      PROB(IMD) = PROBF * PROBS
      if(prob(imd).lt..003) then
ccc         xfac=alog10(prob(imd))
ccc         if(xfac.gt.-2.5) xfac=-2.5
ccc         if(xfac.lt.-4.) xfac=-4.
ccc         ghlos=(xfac+2.5)*20.
ccc         tloss(imd)=tloss(imd)-ghlos
ccc         fldst(imd)=fldst(imd)+ghlos
ccc         sigpow(imd)=sigpow(imd)+ghlos
ccc         sn(imd)=sn(imd)+ghlos
      end if
C  LOWER DECILE  SIGNAL LEVEL ADJUSTMENT
      CPR = FVMUF(ISMOD)/YMUF(ISMOD)
      FVFOT = YFOT(ISMOD)* CPR
      XMUF  = FVFOT * CPHET
      DUMMY = YFOT(ISMOD)
      PFL = PRBMUF(FREQ,XMUF,DUMMY,ISMOD)
      XLSL =  -10.*ALOG10(PFL)/CPHET
      ESD = FS(3,KF)/CPHES
      DUMMY = YHPF(4)
      PROS = PRBMUF(FMHZ,ESD,DUMMY,4)
      PROS = AMIN1( PROS,0.9)
      OBFL = -10.*ALOG10(1.- PROS)
      ESD  = FS(1,KS)/CPHES
      DUMMY = YFOT(4)
      PSL = PRBMUF(FMHZ,ESD,DUMMY,4)
      REFL = 8.9136 * PSL ** (0.7)
      TLLOW( IMD) = DSL + (REFL - REF)  + (OBFL -OBF(IMD))
     A        + HOP*(XLSL - XLSF)
C UPPER DECILE  SIGNAL LEVEL ADJUSTMENT
      FVHPF = YHPF(ISMOD)/CPR
      XMUF = FVHPF*CPHET
      DUMMY = YHPF(ISMOD)
      PHF = PRBMUF(FREQ,XMUF,DUMMY,ISMOD)
      XLSU = -10.*ALOG10(PHF)/CPHET
      ESD = FI(1,KF)/CPHES
      DUMMY = YFOT(4)
      PSU = PRBMUF(FMHZ,ESD,DUMMY,4)
      PSU = AMIN1(PSU, 0.9)
      OBFU = -10.*ALOG10(1.-PSU)
      ESD = FS(3,KS) / CPHES
      DUMMY = YHPF(4)
      PSU = PRBMUF(FMHZ,ESD,DUMMY,4)
       REFU = 8.9136 * PSU **(-0.7)
      TLHGH(IMD) = DSU + (REF - REFU) + (OBF(IMD) - OBFU)
     A           + HOP*(XLSF - XLSU)
      TLHGH(IMD) = ABS(TLHGH(IMD))
C  BUT NO MORE THAN MAX IN TABLES
      TLLOW(IMD) = AMIN1(TLLOW(IMD),25.)
      TLHGH(IMD) = AMIN1(TLHGH(IMD),25.)
  600 CONTINUE
      RETURN
      END
C--------------------------------
